Já olhamos os decks de Gwent para identificar e explorar as regras de associação entre as cartas, o que alavanca as estratégias de utilização das mesmas conhecidas pela comunidade. Neste post vamos tomar outra abordagem e buscar os pares de cartas cujas características são mais similares entre si e que, portanto, poderia fornecer algum outro tipo de estratégia ainda não explorada e/ou facilitar a nossa vida quanto à escolha das cartas que colocaremos em um deck
Há algum tempo atrás construí um scrapper para raspar a biblioteca de decks de Gwent, de forma à usar esses dados para me ajudar a tomar melhores decisões na hora de montar meus próprios decks. Neste sentido, uma das primeiras coisas que fiz foi tentar entender os padrões de co-ocorrência das cartas de Gwent entre os decks contribuídos pela comunidade, utilizando para isso uma análise orientada à regras de associação - técnica muito utilizada em análises de carrinho de compra (i.e., market basket analysis), além de ser uma ferramenta útil na hora de uma análise exploratória de dados. Este primeiro exercício acabou sendo bastante positivo, pois consegui extrair alguns insights bastante importantes que eu não tinha visibilidade, e que acabaram melhorando a minha estratégia e experiência de jogo.
Um ponto importante daquela primeira análise é que ela olha para os padrões de co-ocorrência de cartas conhecidos e explorados pela comunidade, deixando de fora àquelas combinações de cartas que teriam o potencial de funcionar juntas mas que nunca foram testadas. Por exemplo, existe uma mecânica de envenenamento, no qual se uma carta receber este status duas vezes ela é imediatamente destruída. Nesse contexto, existem algumas cartas específicas que são usadas com uma frequência muito alta para implementar esta mecânica, ainda que existam muitas outras cartas que também o possam fazer mas que não são usualmente postas nos decks. As mecânicas implementadas por cada carta são apresentadas em sua descrição, mas existem algumas formas diferentes de descrever um mesmo tipo de mecânica além de diferenças na forma como elas são disparadas entre as as facções. Assim, identificar as cartas que têm mecânicas similares e o potencial de serem usadas juntas passa a ser uma tarefa viável se pudéssemos agrupar as cartas de acordo com os padrões de texto existente em suas descrições.
Uma forma de implementar este agrupamento através do texto é através da modelagem de tópicos, que é uma técnica de aprendizado não-supervisionado que faz uso de modelos estatísticos para encontrar tópicos abstratos que ocorrem em uma coleção de textos através das palavras que os compõem. Existem alguns modelos que podem ser implementados para esta finalidade, sendo o mais conhecido deles a LDA - Latent Dirichlet Allocation; todavia, vou utilizar este post para estudar, explorar e demonstrar as funcionalidades de um outro modelo de tópicos, o STM - Structural Topic Model (Roberts, Stewart, and Tingley (2019)). Meu objetivo com isso será utilizar este modelo para criar uma representação do quão similares as cartas são de acordo com seus padrões de texto e utilizar àquela representação para encontrar as cartas mais similares àquela que eu resolver buscar.
Antes de chegar aos objetivos finais desta análise vamos cobrir alguns pontos importantes. Iniciaremos falando um pouco sobre a aquisição dos dados, passando na sequência para uma breve análise exploratória. Começaremos a modelagem de tópicos falando um pouquinho mais da intuição por trás do STM e, então, vamos implementar tanto uma busca pela quantidade de tópicos que devemos utilizar antes de ajustar o modelo em si. A partir daí conduziremos algumas análises para o pós-processamento, entedimento dos tópicos e validação do modelo, e fecharemos então o post mostrando a aplicação do modelo para atingir os objetivos que defini anteriormente.
# carregando os pacotes
library(tidyverse) # core
library(tidytext) # para manipular texto
library(patchwork) # para compor figuras
library(ggridges) # para o ridge plot
library(stringi) # para trabalhar com texto
library(reactable) # para tabelas interativas
library(reactablefmtr) # para ajudar com o reactable
# carregando os dados
cartas <- read_rds(file = 'data/cartas.rds')
# cartas <- read_rds(file = '_posts/2022-01-31-card-embeddings-parte-1/data/cartas.rds')
# ajustando a tabela por conta de duas cartas má registradas
cartas <- cartas %>%
# removendo a carta Solução Engenhosa, que aparece duas vezes por conta de diferencas
# em seu nome em ingles
filter(!(localizedName == 'Solução engenhosa' & name != 'Blueprint')) %>%
# ajustando o nome da carta Vidente, que aparece duas vezes pois existe uma na facção
# neutra e outra na Scoia'tael, mas sao cartas diferentes
mutate(
localizedName = case_when(localizedName == 'Vidente' ~ paste0(localizedName, ' (', slug, ')'),
TRUE ~ localizedName)
) %>%
# colocando as cartas em ordem alfabetica
arrange(localizedName)
cartas
# A tibble: 1,103 × 19
localizedName name short slug rarity cardGroup type categoryName
<chr> <chr> <chr> <chr> <chr> <chr> <chr> <chr>
1 A Fera The … mon Mons… Épica gold Unid… Espectro
2 A prática le… Prac… nor Nort… Rara bronze Espe… Feitiço
3 A Terra das … Land… neu Neut… Lendá… gold Arte… Local
4 A Trufa Carn… The … neu Neut… Lendá… gold Arte… Local
5 Abaya Abaya mon Mons… Épica gold Unid… Necrófago
6 Aberrações d… Whor… syn Synd… Épica gold Unid… Humano, Bil…
7 Abominação S… Sala… syn Synd… Rara bronze Unid… Fera, Mutan…
8 Acônito Wolf… neu Neut… Lendá… gold Espe… Nenhuma
9 Açougueiro d… Sval… ske Skel… Comum bronze Unid… Humano, Cul…
10 Adaga Cerimo… Cere… neu Neut… Lendá… gold Estr… Estratégia
# … with 1,093 more rows, and 11 more variables: ownable <lgl>,
# decks <int>, craftingCost <int>, power <int>,
# provisionsCost <int>, armour <int>, keywords <chr>, texto <chr>,
# fluff <chr>, small <chr>, big <chr>
Quantas cartas diferentes existem por facção?
cartas %>%
# contando quantidade de cartas existentes por faccao
count(slug, name = 'n_cartas') %>%
# ordenando as colunas
mutate(slug = fct_reorder(.f = slug, .x = n_cartas)) %>%
# criando a figura
ggplot(mapping = aes(x = n_cartas, y = slug, fill = slug)) +
geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
geom_text(mapping = aes(label = n_cartas), nudge_x = 10, fontface = 'bold') +
scale_fill_manual(values = cores_por_faccao) +
labs(
title = 'Quantas cartas diferentes existem por facção?',
x = 'Quantidade de cartas'
) +
theme(axis.title.y = element_blank())
Quais as diferenças nas características das cartas?
## raridade das cartas por faccao
fig_raridade <- cartas %>%
# contando quantidade de cartas existentes por faccao
count(slug, rarity, name = 'n_cartas') %>%
# ordenando as colunas
mutate(
slug = fct_reorder(.f = slug, .x = n_cartas, .fun = sum, .desc = FALSE),
rarity = fct_reorder(.f = rarity, .x = n_cartas, .fun = sum, .desc = TRUE),
) %>%
# agrupando pela raridade
group_by(slug) %>%
# calculando a proporcao de cartas por faccao
mutate(
proporcao = n_cartas / max(n_cartas)
) %>%
# criando a figura
ggplot(mapping = aes(y = slug, x = rarity, fill = proporcao)) +
geom_tile(color = 'white', show.legend = FALSE) +
geom_text(mapping = aes(label = n_cartas), color = 'white') +
scale_fill_viridis_c(begin = 0.1, end = 0.8) +
labs(title = 'Raridade das cartas') +
theme(axis.title = element_blank())
# tipo de carta por faccao
fig_tipo <- cartas %>%
# contando quantidade de cartas existentes por faccao
count(slug, type, name = 'n_cartas') %>%
# ordenando as colunas
mutate(
type = fct_reorder(.f = type, .x = n_cartas, .fun = sum, .desc = TRUE),
slug = fct_reorder(.f = slug, .x = n_cartas, .fun = sum, .desc = FALSE)
) %>%
# agrupando pela raridade
group_by(slug) %>%
# calculando a proporcao de cartas por faccao
mutate(
proporcao = n_cartas / max(n_cartas)
) %>%
# completando todas as combinacoes de tipo e faccao
complete(slug, type) %>%
# criando a figura
ggplot(mapping = aes(y = slug, x = type, fill = proporcao)) +
geom_tile(color = 'white', show.legend = FALSE) +
geom_text(mapping = aes(label = n_cartas), color = 'white') +
scale_fill_viridis_c(begin = 0.1, end = 0.8, na.value = 'white') +
labs(title = 'Tipos de cartas') +
theme(axis.title = element_blank())
# poder das cartas por faccao
fig_poder <- cartas %>%
# pegando apenas as cartas de unidade
filter(type == 'Unidade') %>%
# ordenando as colunas
mutate(slug = fct_reorder(.f = slug, .x = power, .fun = mean)) %>%
# criando a figura
ggplot(mapping = aes(x = power, y = slug, fill = slug)) +
geom_density_ridges(scale = 0.95, show.legend = FALSE,
jittered_points = TRUE,
position = position_points_jitter(width = 0.01, height = 0),
point_shape = '|', point_size = 3, point_alpha = 1, alpha = 0.7) +
scale_fill_manual(values = cores_por_faccao) +
scale_x_continuous(breaks = seq(from = 0, to = 15, by = 1)) +
labs(
title = 'Poder das cartas do tipo Unidade',
x = 'Poder'
) +
theme(axis.title.y = element_blank())
# poder das cartas por faccao
fig_armadura <- cartas %>%
# pegando apenas as cartas de unidade
filter(type == 'Unidade') %>%
# ordenando as colunas
mutate(slug = fct_reorder(.f = slug, .x = armour, .fun = mean)) %>%
# criando a figura
ggplot(mapping = aes(x = armour, y = slug, fill = slug)) +
geom_density_ridges(scale = 0.95, show.legend = FALSE,
jittered_points = TRUE,
position = position_points_jitter(width = 0.01, height = 0),
point_shape = '|', point_size = 3, point_alpha = 1, alpha = 0.7) +
scale_fill_manual(values = cores_por_faccao) +
scale_x_continuous(breaks = seq(from = 0, to = 10, by = 1)) +
labs(
title = 'Armadura das cartas do tipo Unidade',
x = 'Armadura'
) +
theme(axis.title.y = element_blank())
# compondo a figura
(fig_raridade + fig_tipo) / (fig_poder + fig_armadura) +
plot_annotation(tag_levels = 'A', tag_prefix = '(', tag_suffix = ')') &
theme(plot.tag = element_text(size = 10, face = 'bold'))
De que forma as categorias das cartas de Unidade variam entre facções?
cartas %>%
# pegando apenas as cartas de unidade
filter(type == 'Unidade') %>%
# quebrando o string em tokens
unnest_tokens(output = token, input = categoryName, to_lower = FALSE,
token = 'regex', pattern = ', ') %>%
# contando as categorias por faccao
count(slug, token, name = 'ocorrencias') %>%
# contando quantas vezes cada token aparece entre as faccoes
add_count(token, name = 'faccoes_nos_tokens') %>%
# contando quantas vezes as faccoes aparecem entre os tokens
add_count(slug, name = 'tokens_nas_faccoes') %>%
# agrupando por faccao
mutate(
token = fct_reorder(.f = token, .x = faccoes_nos_tokens, .desc = FALSE),
slug = fct_reorder(.f = slug, .x = tokens_nas_faccoes, .desc = TRUE)
) %>%
# agrupando pelo token
group_by(token) %>%
# proporcao de vezes que cada token aparece entre as faccoes
mutate(proporcao = ocorrencias / max(ocorrencias)) %>%
# desagrupando o dataframe
ungroup %>%
# completando as combinacoes faltantes de token e faccao
complete(token, slug) %>%
# criando a figura
ggplot(mapping = aes(x = slug, y = token, fill = proporcao)) +
geom_tile(color = 'black', show.legend = FALSE) +
geom_text(mapping = aes(label = ocorrencias, color = proporcao > 0.5), show.legend = FALSE) +
scale_fill_viridis_c(begin = 0.2, end = 0.9, na.value = 'white') +
scale_color_manual(values = c('white', 'black')) +
labs(
title = 'Quais os tipos de personagem associados às cartas de cada facção?'
) +
theme(
axis.title = element_blank()
)
Quais as habilidades mais comuns das cartas por facção?
cartas %>%
# quebrando o string em tokens
unnest_tokens(output = token, input = keywords, to_lower = FALSE,
token = 'regex', pattern = ';') %>%
# removendo os NAs
filter(!is.na(token)) %>%
# contando as categorias por faccao
count(slug, token, name = 'ocorrencias') %>%
# contando quantas vezes cada token aparece entre as faccoes
add_count(token, name = 'faccoes_com_token') %>%
# contando quantas vezes as faccoes aparecem entre os tokens
add_count(slug, name = 'tokens_nas_faccoes') %>%
# agrupando por faccao
mutate(
token = fct_reorder(.f = token, .x = faccoes_com_token, .desc = FALSE),
slug = fct_reorder(.f = slug, .x = tokens_nas_faccoes, .desc = TRUE)
) %>%
# agrupando pelo token
group_by(token) %>%
# proporcao de vezes que cada token aparece entre as faccoes
mutate(proporcao = ocorrencias / max(ocorrencias)) %>%
# desagrupando o dataframe
ungroup %>%
# completando as combinacoes faltantes de token e faccao
complete(token, slug) %>%
# criando a figura
ggplot(mapping = aes(x = slug, y = token, fill = proporcao)) +
geom_tile(color = 'black', show.legend = FALSE) +
geom_text(mapping = aes(label = ocorrencias, color = proporcao > 0.5), show.legend = FALSE) +
scale_fill_viridis_c(begin = 0.2, end = 0.9, na.value = 'white') +
scale_color_manual(values = c('white', 'black')) +
labs(
title = 'Quais os tipos de habilidade associados às cartas de cada facção?'
) +
theme(
axis.title = element_blank()
)
Habilidades únicas às facções.
cartas %>%
# quebrando o string em tokens
unnest_tokens(output = token, input = keywords, to_lower = FALSE,
token = 'regex', pattern = ';') %>%
# removendo os NAs
filter(!is.na(token)) %>%
# contando as categorias por faccao
count(slug, token, name = 'ocorrencias') %>%
# calculando o tf-idf
bind_tf_idf(term = token, document = slug, n = ocorrencias) %>%
# agrupando pela faccao
group_by(slug) %>%
# pegando os 10 tokens com maior tf-idf
slice_max(order_by = tf_idf, n = 10, with_ties = FALSE) %>%
# desagrupando
ungroup %>%
# ordenando as colunas
mutate(token = reorder_within(x = token, by = tf_idf, within = slug)) %>%
# criando a figura
ggplot(mapping = aes(x = tf_idf, y = token, fill = slug)) +
facet_wrap(~ slug, scales = 'free') +
geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
scale_y_reordered() +
scale_fill_manual(values = cores_por_faccao) +
labs(
title = 'Quais as habilidades particulares às cartas de cada facção?',
x = 'TF-IDF'
) +
theme(axis.title.y = element_blank())
Texto da carta.
cartas %>%
# quebrando o string em tokens
unnest_tokens(output = token, input = texto, to_lower = TRUE) %>%
# removendo os NAs e algumas palavras que não ajudam a visualização
filter(!is.na(token),
str_detect(string = token, pattern = "scoia'tael|reinos|skellige|norte|dos", negate = TRUE)) %>%
# contando as categorias por faccao
count(slug, token, name = 'ocorrencias') %>%
# calculando o tf-idf
bind_tf_idf(term = token, document = slug, n = ocorrencias) %>%
# agrupando pela faccao
group_by(slug) %>%
# pegando os 15 tokens com maior tf-idf
slice_max(order_by = tf_idf, n = 15, with_ties = FALSE) %>%
# desagrupando
ungroup %>%
# ordenando as colunas
mutate(token = reorder_within(x = token, by = tf_idf, within = slug)) %>%
# criando a figura
ggplot(mapping = aes(x = tf_idf, y = token, fill = slug)) +
facet_wrap(~ slug, scales = 'free') +
geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
scale_y_reordered() +
scale_fill_manual(values = cores_por_faccao) +
labs(
title = 'Quais as habilidades particulares às cartas de cada facção?',
x = 'TF-IDF'
) +
theme(axis.title.y = element_blank())
Lista de stopwords personalizada.
my_stopwords <- c('a', 'ao', 'aos', 'ate', 'cada', 'com', 'as', 'como', 'da', 'das',
'de', 'dela', 'delas', 'dele', 'desta', 'deste', 'destas', 'destes',
'deles', 'do', 'dos', 'disso', 'e', 'es', 'em', 'esta', 'ela', 'ele',
'elas', 'eles', 'for', 'foi', 'la', 'lhe', 'mais', 'nas', 'nesta',
'na', 'nas', 'nela', 'nele', 'no', 'nos', 'o', 'os', 'ou', 'para',
'por', 'pelo', 'que', 'sao', 'se', 'so', 'sos', 'sem', 'seu', 'seus',
'sua', 'suas', 's', 'si', 'todas', 'todos', 'tem', 'um', 'uma', 'voce',
'vez', 'longa', 'distancia', 'corpo', 'duas', 'dois', 'metade', 'reinos',
'norte', "scoia'tael", 'skellige', 'nilfgaard', 'sindicato', 'neutra',
'concede', 'tiver', 'seguida', 'seja', 'caso', 'faz', 'usa', 'usar',
'usando', 'usada', 'usado', 'tambem', 'houver', 'ha', 'pela', 'mesma',
'tiver', 'nao', 'nessa', 'nessas', 'nesse', 'nesses', 'qualquer',
'estiver', 'entre', 'unidade', 'unidades', 'mobilizacao', 'sempre',
'mesmo', 'perto', 'apos', 'quando', 'neste', 'nestes', "scoia'tel",
'enquanto')
Preparando os dados.
txt <- 'Esta habilidade adiciona [0-9]{2} (?:(?:de )?recrutamento[s]? ao limite )?de recrutamento (ao limite )?do (?:seu )?baralho.'
# contando ocorrencias de cada token por faccao
df_tokens <- cartas %>%
# removendo texto comum a todas as cartas de habilidade do lider
mutate(
texto = str_remove(string = texto, pattern = txt)
) %>%
# quebrando o string em tokens
unnest_tokens(output = token, input = texto) %>%
# removendo acentuacao
mutate(token = stri_trans_general(str = token, id = 'Latin-ASCII')) %>%
# removendo stopwords
filter(!token %in% my_stopwords) %>%
# removendo os digitos
filter(str_detect(string = token, pattern = '[0-9]', negate = TRUE)) %>%
# substituindo algumas formas
mutate(
token = str_replace(string = token, pattern = '(?<=o|a)s$', replacement = ''),
token = str_replace(string = token, pattern = '(?<=d|t)es$', replacement = 'e'),
token = str_replace(string = token, pattern = '(?<=r)es$', replacement = ''),
token = str_replace(string = token, pattern = 'veneno|envenenamento|envenenad[ao]', replacement = 'envenena'),
token = str_replace(string = token, pattern = 'bloqueada|bloquei[ao]', replacement = 'bloqueio'),
token = str_replace(string = token, pattern = 'reforcad[ao]', replacement = 'reforcada'),
token = str_replace(string = token, pattern = 'anoes', replacement = 'anao'),
token = str_replace(string = token, pattern = 'aleatoriamente', replacement = 'aleatorio'),
token = str_replace(string = token, pattern = 'aleatoria', replacement = 'aleatorio'),
) %>%
# contando ocorrencia dos lemmas por carta
count(localizedName, token, name = 'ocorrencias')
df_tokens
# A tibble: 7,425 × 3
localizedName token ocorrencias
<chr> <chr> <int>
1 A Fera batalha 1
2 A Fera campo 1
3 A Fera fim 1
4 A Fera maior 1
5 A Fera poder 1
6 A Fera reforca 1
7 A Fera turno 1
8 A prática leva à perfeição aleatorio 1
9 A prática leva à perfeição aliado 1
10 A prática leva à perfeição aumenta 1
# … with 7,415 more rows
Lematizando os tokens e contando-os.
# carregando mais pacotes
library(spacyr) # para ajudar com lematizacao
# inicializando o spacy
spacy_initialize(model = 'pt_core_news_lg')
# criando uma base de-para para lemmatizar os tokens
de_para_lemma <- distinct(df_tokens, token) %>%
# colocando os tokens em um vetor
pull(token) %>%
# parseando os tokens para o spacyr
spacy_parse(pos = FALSE, tag = FALSE, lemma = TRUE, dependency = FALSE) %>%
# passando o resultado para um tibble
tibble %>%
# pegando apenas as colunas que interessam
select(token, lemma)
# lemmatizando os tokens e contando ocorrencias
df_tokens <- df_tokens %>%
# juntando o de-para de lemmas aos tokens
left_join(y = de_para_lemma, by = 'token') %>%
# contando ocorrencia dos lemmas por carta
count(localizedName, lemma, name = 'ocorrencias')
df_tokens
Criando matriz DFM.
# criando matriz no formato document-feature matrix
df_esparsa <- df_tokens %>%
cast_sparse(row = localizedName, column = token, value = ocorrencias)
Procurando o valor de K.
# carregando mais pacotes
library(stm) # para a modelagem de topicos
library(furrr) # para paralelizar a busca
# setando a seed
set.seed(33)
# setando o processamento paralelo
plan(multisession)
# buscando melhor valor de K
search_K <- tibble(
K = seq(from = 6, to = 30, by = 3)
) %>%
mutate(
# rodando o STM sem nenhuma feature
padrao = future_map(.x = K,
.f = ~ stm(documents = df_esparsa, init.type = 'Spectral',
seed = 333, K = .x, verbose = FALSE),
.options = furrr_options(seed = TRUE)
),
# passando a faccao para o content
features = future_map(.x = K,
.f = ~ stm(documents = df_esparsa, init.type = 'Spectral',
seed = 333, K = .x, content = ~ slug, data = cartas,
verbose = FALSE),
.options = furrr_options(seed = TRUE)
)
) %>%
pivot_longer(cols = c(padrao, features), names_to = 'tipo', values_to = 'modelos')
# setando o processamento sequencial
plan(sequential)
Extraindo métricas de avaliação.
# extraindo as metricas de avaliacao da clusterizacao
metricas <- search_K %>%
# calculando a exclusividade e a coerencia dos topicos
mutate(
exclusividade = map(.x = modelos, .f = safely(exclusivity)),
exclusividade = map(.x = exclusividade, .f = 'result'),
coerencia = map(.x = modelos, .f = semanticCoherence, documents = df_esparsa),
residuos = map(.x = modelos, .f = checkResiduals, df_esparsa),
residuos = map(.x = residuos, 'dispersion')
) %>%
# dropando a coluna com os modelos
select(-modelos) %>%
# desaninhando as colunas de coerencia e exclusividade
unnest(cols = c(exclusividade, coerencia, residuos))
# plotando as metricas individualmente
fig_painel_metricas <- metricas %>%
# passando a base para o formato longo
pivot_longer(cols = c(exclusividade, coerencia, residuos),
names_to = 'metrica', values_to = 'valor') %>%
# dropando valores nulos
drop_na() %>%
# agrupando pelo valor de K e da metrica
group_by(K, metrica, tipo) %>%
# calculando o valor da media da metrica por valor de K
summarise(
valor = mean(x = valor, na.rm = TRUE), .groups = 'drop'
) %>%
# renomeando as metricas
mutate(
metrica = case_when(metrica == 'coerencia' ~ 'Coerência Semântica',
TRUE ~ str_to_title(string = metrica))
) %>%
# criando a figura
ggplot(mapping = aes(x = as.factor(K), y = valor, group = tipo, color = tipo)) +
facet_wrap(~ metrica, scales = 'free') +
geom_line(size = 1, show.legend = FALSE) +
geom_point(fill = 'white', color = 'black', shape = 21, size = 3, show.legend = FALSE) +
labs(
caption = 'A linha azul representa o modelo que não contempla que a ocorrência das palavras pode variar dentro dos tópicos em função da identidade da facção.',
x = 'Quantidade de tópicos (K)',
y = 'Valor da métrica'
)
# plotando as metricas de coerencia vs exclusividade
fig_coerencia_exclusividade <- metricas %>%
# filtrando os resultado do modelo sem content
filter(tipo == 'padrao') %>%
# adicionando a sequencia do numero de topicos
mutate(
K = ifelse(test = K < 10, yes = paste0('0', K), no = K),
K = paste(K, 'tópicos')
) %>%
# criando a figura
ggplot(mapping = aes(x = coerencia, y = exclusividade, color = K)) +
facet_wrap(~ K) +
geom_point(shape = 16, size = 3, show.legend = FALSE) +
scale_color_viridis_d(direction = -1, begin = 0.2, end = 0.9) +
labs(
x = 'Coerência Semântica',
y = 'Exclusividade'
)
# criando o painel
(fig_painel_metricas / fig_coerencia_exclusividade) +
plot_layout(heights = c(1, 2)) +
plot_annotation(
title = 'Quantos tópicos devemos usar?',
subtitle = 'A quantidade de tópicos escolhida deve atender ao melhor balanço entre uma alta coerência semântica e exclusividade',
tag_levels = 'A', tag_prefix = '(', tag_suffix = ')') &
theme(plot.tag = element_text(size = 10, face = 'bold'))
Ajustando o modelo de tópicos
Visualizando os topicos encontrados.
# criando figura das palavras por topicos
tidy(x = modelo, matrix = 'beta') %>%
# agrupando pelo topico
group_by(topic) %>%
# pegando as 10 palavras com maior afinade com cada tópico
slice_max(order_by = beta, n = 10, with_ties = FALSE) %>%
# criando escala numerica para colorir dentro dos topicos
mutate(escala = beta / max(beta)) %>%
# desagrupando os dados
ungroup %>%
# organizando as informacoes para plotar
mutate(
topic = ifelse(test = topic < 10,
yes = paste0('Tópico 0', topic), no = paste0('Tópico', topic)),
term = reorder_within(x = term, by = beta, within = topic)
) %>%
# criando a figura
ggplot(mapping = aes(x = beta, y = term, fill = escala)) +
facet_wrap(~ topic, scales = 'free', ncol = 4) +
geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
scale_y_reordered() +
scale_fill_viridis_c(begin = 0.2, end = 0.9) +
labs(
title = 'Quais as palavras mais prováveis de serem observadas em cada tópico?',
x = expression(bold(paste('Probabilidade de ocorrência, ', beta)))
) +
theme(axis.title.y = element_blank())
Visualizando os topicos encontrados - parte 2.
# extraindo os dados dos betas por topico
df_betas <- modelo$beta %>%
# pegando a matriz com o log das probabilidades para o beta
pluck('logbeta') %>%
# parseando as matrizes para um dataframe
map(.f = data.frame) %>%
# passando o log da probabilidade para probabilidade
map(.f = exp) %>%
# colocando o nome nas colunas
map(.f = ~ `colnames<-`(x = ., value = df_esparsa@Dimnames[[2]])) %>%
# adicionando o identificador do topico a cada linha
map(.f = mutate, topic = 1:n()) %>%
# renomeando os elementos da lista
`names<-`(value = c('Monsters', 'Neutral', 'Nilfgaard', 'Northern Realms',
"Scoia'tael", 'Skellige', 'Syndicate')) %>%
# juntando todos
map_dfr(tibble, .id = 'slug') %>%
# passando a base para o formato longo
pivot_longer(cols = -c(slug, topic), names_to = 'term', values_to = 'beta')
# criando figura das palavras por topicos
df_betas %>%
# agrupando pelo topico e token
group_by(topic, term) %>%
# calculando a media da probabilidade para aquele token naquele topico
summarise(beta = mean(x = beta, na.rm = TRUE), .groups = 'drop') %>%
# agrupando pelo topico
group_by(topic) %>%
# pegando as 10 palavras com maior afinade com cada tópico
slice_max(order_by = beta, n = 10, with_ties = FALSE) %>%
# criando escala numerica para colorir dentro dos topicos
mutate(escala = beta / max(beta)) %>%
# desagrupando os dados
ungroup %>%
# organizando as informacoes para plotar
mutate(
topic = ifelse(test = topic < 10,
yes = paste0('Tópico 0', topic), no = paste0('Tópico', topic)),
term = reorder_within(x = term, by = beta, within = topic)
) %>%
# criando a figura
ggplot(mapping = aes(x = beta, y = term, fill = escala)) +
facet_wrap(~ topic, scales = 'free', ncol = 4) +
geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
scale_y_reordered() +
scale_fill_viridis_c(begin = 0.2, end = 0.9) +
labs(
title = 'Quais as palavras mais prováveis de serem observadas em cada tópico?',
x = expression(bold(paste('Probabilidade de ocorrência, ', beta)))
) +
theme(axis.title.y = element_blank())
Visualizando a proporcao de topicos.
# criando tabela com as 5 palavras mais frequentes por topico para plotarmos abaixo
df_top_palavras <- tidy(x = modelo, matrix = 'beta') %>%
# agrupando pelo topico
group_by(topic) %>%
# pegando as 10 palavras com maior afinade com cada tópico
slice_max(order_by = beta, n = 5, with_ties = FALSE) %>%
# colocando essas palavras em um vetor
summarise(palavras = paste0(term, collapse = ', '))
# se usarmos o content quando rodar o STM, é necessário descomentar as linhas abaixo
# df_top_palavras <- df_betas %>%
# # agrupando pelo topico e token
# group_by(topic, term) %>%
# # calculando a media da probabilidade para aquele token naquele topico
# summarise(beta = mean(x = beta, na.rm = TRUE), .groups = 'drop') %>%
# # agrupando pelo topico
# group_by(topic) %>%
# # pegando as 10 palavras com maior afinade com cada tópico
# slice_max(order_by = beta, n = 5, with_ties = FALSE) %>%
# # colocando essas palavras em um vetor
# summarise(palavras = paste0(term, collapse = ', '))
# criando a figura de prevalencia por topico
tidy(x = modelo, matrix = 'gamma') %>%
# agrupando pelo topico
group_by(topic) %>%
# extraindo a media da probabilidade para cada topico
# esse é o valor esperado da prevalencia do tópico
summarise(
media = mean(x = gamma), .groups = 'drop'
) %>%
# juntando as 5 palavras mais frequentes por topico
left_join(y = df_top_palavras, by = 'topic') %>%
# reordenando as colunas
mutate(
topic = ifelse(test = topic < 10, yes = paste0('0', topic), no = topic),
topic = paste('Tópico', topic),
topic = fct_reorder(.f = topic, .x = media)
) %>%
# criando a figura
ggplot(mapping = aes(x = media, y = topic, fill = media)) +
geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
geom_text(mapping = aes(label = round(x = media, digits = 3), color = media <= 0.04),
nudge_x = -0.01, fontface = 'bold', show.legend = FALSE) +
geom_text(mapping = aes(label = palavras), nudge_x = 0.005, hjust = 0) +
scale_x_continuous(breaks = seq(from = 0, to = 0.25, by = 0.05),
limits = c(0, 0.27)) +
scale_fill_viridis_c(begin = 0.2, end = 0.9) +
scale_color_manual(values = c('black', 'white')) +
labs(
title = 'Quais os tópicos mais prevalentes entre as cartas?',
x = expression(bold(paste('Probabilidade de ocorrência, ', gamma)))
) +
theme(axis.title.y = element_blank())
Visualiza correlação entre topicos.
# carregando pacotes
library(corrr) # para o plot abaixo
# criando uma plot de correlacao entre os topicos
topicCorr(model = modelo) %>%
# pegando a matriz de correlacao
pluck('cor') %>%
# colocando o nome das dimensoes
`rownames<-`(value = paste0('Tópico ', 1:18)) %>%
`colnames<-`(value = paste0('Tópico ', 1:18)) %>%
# passando para uma matriz do corrr
as_cordf() %>%
# passando a matriz de correlacao para o formato longo
stretch(na.rm = TRUE, remove.dups = TRUE) %>%
# adicionando contagem de ocorrencias de x e y para ordenar as linhas
# e colunas da figura
add_count(x, name = 'n_x') %>%
add_count(y, name = 'n_y') %>%
mutate(
y = fct_reorder(.f = y, .x = n_y, .desc = TRUE),
x = fct_reorder(.f = x, .x = n_x, .desc = TRUE)
) %>%
# criando a figura
ggplot(mapping = aes(x = x, y = y, fill = r)) +
geom_tile(color = 'black') +
geom_text(mapping = aes(label = round(x = r, digits = 2), color = abs(x = r) > 0.3),
fontface = 'bold', show.legend = FALSE) +
scale_fill_gradient2(low = 'midnightblue', mid = 'white', high = 'firebrick', midpoint = 0) +
scale_color_manual(values = c('NA', 'black')) +
labs(
title = 'Qual a relação entre os tópicos identificados?',
subtitle = 'São poucos os tópicos que compartilham algum tipo de relação'
) +
theme(
axis.title = element_blank(),
panel.grid = element_blank(),
axis.text.x = element_text(angle = 30, hjust = 1)
)
Estimando a relacao entre topicos e metadados.
# estimando a contribuicao das features para explicar os clusters
explica_topicos <- estimateEffect(1:18 ~ 0 + slug, stmobj = modelo,
metadata = cartas, uncertainty = 'Global')
# pegando os slopes das regressoes
tidy(x = explica_topicos) %>%
# ajustando os dados para plotar
mutate(
# ajustando o nome das faccoes
term = str_remove(string = term, pattern = 'slug'),
term = str_replace_all(string = term, pattern = '\\(Intercept\\)', replacement = 'Monsters'),
# criando codificacao de cor a partir do nome original da faccao
cores = term,
# ajustando o nome dos topicos
topic = ifelse(test = topic < 10, yes = paste0('Tópico 0', topic), no = paste0('Tópico ', topic)),
# ordenando as faccoes dentro dos topicos atraves da estimativa do slope
term = reorder_within(x = term, by = estimate, within = topic)
) %>%
# criando a figura
ggplot(mapping = aes(x = estimate, y = term, fill = cores, group = 1)) +
facet_wrap(~ topic, scales = 'free', ncol = 4) +
geom_col(color = 'black', size = 0.3, show.legend = FALSE) +
scale_y_reordered() +
scale_fill_manual(values = cores_por_faccao) +
labs(
title = 'Quais as facções mais relacionadas com cada tópico?',
x = 'Coeficientes da regressão'
) +
theme(axis.title.y = element_blank())
Juntando probabilidades às cartas.
# pegando a matriz gamma - as probabilidade de cada topico por documento
embeddings <- tidy(x = modelo, matrix = 'gamma') %>%
# juntando o prefixo topic_ ao numero de cada topico
mutate(topic = paste0('topic_', topic)) %>%
# pivoteando a tabela para o formato largo
pivot_wider(id_cols = document, names_from = topic, values_from = gamma) %>%
# agrupando o dataframe por linha
rowwise() %>%
# extraindo o topico mais provavel por linha
mutate(
topK = which.max(c_across(contains('topic_'))),
topK = ifelse(test = topK < 10, yes = paste0('Tópico 0', topK), no = paste0('Tópico ', topK))
) %>%
# desagrupando o dataframe
ungroup %>%
# colocando o nome das cartas na coluna do nome do documento
mutate(document = cartas$localizedName) %>%
# juntando os metadados das cartas
left_join(y = cartas, by = c('document' = 'localizedName'))
embeddings
# A tibble: 1,103 × 38
document topic_1 topic_2 topic_3 topic_4 topic_5 topic_6 topic_7
<chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 A Fera 0.0316 0.0332 0.0424 0.0106 0.0268 0.0849 0.00470
2 A prática … 0.0167 0.0287 0.0481 0.0557 0.0341 0.0468 0.00585
3 A Terra da… 0.0189 0.0473 0.217 0.0431 0.0249 0.0171 0.0122
4 A Trufa Ca… 0.0122 0.0621 0.0513 0.0582 0.0525 0.0129 0.0105
5 Abaya 0.0104 0.0338 0.0116 0.0229 0.00804 0.00995 0.00962
6 Aberrações… 0.0211 0.0329 0.0166 0.00459 0.0219 0.0361 0.00431
7 Abominação… 0.0997 0.0287 0.0440 0.00978 0.0335 0.0575 0.00421
8 Acônito 0.0346 0.0199 0.0221 0.00995 0.00459 0.312 0.00299
9 Açougueiro… 0.0267 0.0530 0.0191 0.00652 0.0146 0.0826 0.00914
10 Adaga Ceri… 0.0324 0.0815 0.0233 0.00861 0.0123 0.106 0.0129
# … with 1,093 more rows, and 30 more variables: topic_8 <dbl>,
# topic_9 <dbl>, topic_10 <dbl>, topic_11 <dbl>, topic_12 <dbl>,
# topic_13 <dbl>, topic_14 <dbl>, topic_15 <dbl>, topic_16 <dbl>,
# topic_17 <dbl>, topic_18 <dbl>, topK <chr>, name <chr>,
# short <chr>, slug <chr>, rarity <chr>, cardGroup <chr>,
# type <chr>, categoryName <chr>, ownable <lgl>, decks <int>,
# craftingCost <int>, power <int>, provisionsCost <int>, …
Ajustando TSNE.
# carregando o pacote
library(Rtsne) # para rodar o TSNE
library(plotly) # para visualizar o TSNE
# setando a seed
set.seed(33)
# ajustando o TSNE
tsne_results <- select(embeddings, contains('topic_')) %>%
# passando objeto para matrix
as.matrix() %>%
# ajustando tSNE
Rtsne(check_duplicates = FALSE, perplexity = 20)
# plotando resultados do TSNE
tsne_results %>%
# pegando os resultado do TSNE
pluck('Y') %>%
# passando para um dataframe
data.frame %>%
# renomeando as colunas
`names<-`(value = c('tsne1', 'tsne2')) %>%
# passando para um tibble
tibble %>%
# juntando com o nome das cartas
bind_cols(embeddings) %>%
# criando a figura
plot_ly(x = ~ tsne1, y = ~ tsne2, color = ~ slug, data = ., colors = cores_por_faccao,
mode = 'markers', type = 'scatter', marker = list(size = 7, opacity = 0.7),
hoverinfo = 'text',
hovertext = ~ paste0(
'<b>Tópico prevalente:</b> ', topK, '<br>',
'<b>Carta:</b> ', document, '<br>',
'<b>Raridade:</b> ', rarity, '<br>',
'<b>Tipo:</b> ', type, '<br>',
str_wrap(string = texto, width = 50)
)
) %>%
layout(xaxis = list(title = 'Dimensão 1'), yaxis = list(title = 'Dimensão 2'))
Nearest neighbors.
# carregando funcoes
library(widyr) # para trabalhar em formato largo
# colocando os embeddings no formato para a funcao abaixo
df_embedding <- select(embeddings, document, contains('topic_')) %>%
# passando a base para o formato longo
pivot_longer(cols = contains('topic_'), names_to = 'topico', values_to = 'probabilidade')
# criando funcao para calcular o nearest neighbors
nearest_neighbors <- function(df, carta, vizinhos) {
# pegando a faccao da carta selecionada
faccao_selecionada <- cartas %>%
# filtrando a carta selecionada
filter(localizedName == carta) %>%
# pegando a faccao da carta
pull(slug)
# filtrando as cartas que serao comparadas
if(faccao_selecionada != 'Neutral') {
cartas_usaveis <- cartas %>%
# filtrando todas as cartas da faccao da carta selecionada
filter(slug %in% faccao_selecionada) %>%
# pegando o nome das cartas
pull(localizedName)
# pegando todas as cartas caso a facção da carta alvo seja a neutra
} else {
cartas_usaveis <- pull(cartas, localizedName)
}
# calculando a similaridade de coseno entre todas as cartas e a carta alvo
df %>%
# filtrando apenas as cartas que serao comparadas
filter(document %in% cartas_usaveis) %>%
# aplicando a funcao
widely(
~ {
# cria matriz n x m, onde n eh o numero de cartas que existem na base de dados, e m
# é o número de tópicos identificados através do STM - o conteúdo de cada célular na
# matriz é a probabilidade de que àquela carta esteja associada aquele tópico
y <- .[rep(carta, nrow(.)), ]
# no codigo abaixo o '.' representa a matriz de probablidades de cada carta possuir
# cada tópico, e é uma matriz n x m onde o n é cada uma das cartas e o m corresponde
# a várias colunas que representam cada um dos tópicos. Calcularemos então a similaridade
# do conseno a carta selecionado e o embedding representado por cada outra carta:
# - rowSums(. * y): multiplica a matriz do embedding de todos as cartas pela matriz
# da carta selecionada
# - sqrt(rowSums(. ^ 2)): retorna um vetor numerico, com um elemento por carta o valor
# associado à cada carta representa o somatorio dos valores entre todas as dimensoes
# de seu embedding (i.e., todos os topicos associado àquela carta)
# sqrt(sum(.[token, ] ^ 2)): retorna um valor numérico, que representa o somatório dos
# valores entre todas as dimensoes do embedding para a carta selecionada
# (sqrt(rowSums(. ^ 2)) * sqrt(sum(.[token, ] ^ 2))): multiplica o valor do embedding
# de cada carta pelo da carta selecionado, padronizando a similaridade calculada
# pelo 'rowSums(. * y)'
similaridade_coseno <- rowSums(. * y) / (sqrt(rowSums(. ^ 2)) * sqrt(sum(.[carta, ] ^ 2)))
# coloca o resultado em uma matriz com o nome de linha vinda do nome das cartas
#matrix(similaridade_coseno, ncol = 1, dimnames = list(x = names(similaridade_coseno)))
},
sort = TRUE
)(document, topico, probabilidade) %>%
# organizando as cartas em ordem decrescente de similaridade
arrange(desc(item2)) %>%
# pegando apenas a quantidade desejada de cartas similares
slice_max(order_by = item2, n = vizinhos) %>%
# juntando com metadados das cartas resultantes
left_join(y = select(cartas, localizedName, slug, small, texto), by = c('item1' = 'localizedName'))
}
Exemplo Scoia’tael.
df_embedding %>%
# calculando o nearest neighbors
nearest_neighbors(carta = 'Bruxo Gato', vizinhos = 5) %>%
# selecionando as colunas que vamos plotar
select(small, item1, item2, texto) %>%
# adicionando o prefixo do link para a imagem
mutate(small = paste0('https://www.playgwent.com/', small)) %>%
# colocando os exemplos em um reactable
reactable(
compact = TRUE, borderless = TRUE, defaultColDef = colDef(align = 'left'),
style = list(fontFamily = "Roboto", fontSize = "12px"),
columns = list(
small = colDef(name = '', cell = embed_img(height = 80, width = 60), maxWidth = 80),
item1 = colDef(name = 'Carta', maxWidth = 90),
item2 = colDef(name = 'Similaridade', maxWidth = 90, format = colFormat(digits = 3)),
texto = colDef(name = 'Descrição')
)
)
Exemplo Northern Realms.
df_embedding %>%
# calculando o nearest neighbors
nearest_neighbors(carta = 'Imortais', vizinhos = 5) %>%
# selecionando as colunas que vamos plotar
select(small, item1, item2, texto) %>%
# adicionando o prefixo do link para a imagem
mutate(small = paste0('https://www.playgwent.com/', small)) %>%
# colocando os exemplos em um reactable
reactable(
compact = TRUE, borderless = TRUE, defaultColDef = colDef(align = 'left'),
style = list(fontFamily = "Roboto", fontSize = "12px"),
columns = list(
small = colDef(name = '', cell = embed_img(height = 80, width = 60), maxWidth = 80),
item1 = colDef(name = 'Carta', maxWidth = 140),
item2 = colDef(name = 'Similaridade', maxWidth = 90, format = colFormat(digits = 3)),
texto = colDef(name = 'Descrição')
)
)
Exemplo Nilfgaard.
df_embedding %>%
# calculando o nearest neighbors
nearest_neighbors(carta = 'Artorius Viggo', vizinhos = 5) %>%
# selecionando as colunas que vamos plotar
select(small, item1, item2, texto) %>%
# adicionando o prefixo do link para a imagem
mutate(small = paste0('https://www.playgwent.com/', small)) %>%
# colocando os exemplos em um reactable
reactable(
compact = TRUE, borderless = TRUE, defaultColDef = colDef(align = 'left'),
style = list(fontFamily = "Roboto", fontSize = "12px"),
columns = list(
small = colDef(name = '', cell = embed_img(height = 80, width = 60), maxWidth = 80),
item1 = colDef(name = 'Carta', maxWidth = 140),
item2 = colDef(name = 'Similaridade', maxWidth = 90, format = colFormat(digits = 3)),
texto = colDef(name = 'Descrição')
)
)
Exemplo Neutral.
df_embedding %>%
# calculando o nearest neighbors
nearest_neighbors(carta = 'Alzur', vizinhos = 5) %>%
# selecionando as colunas que vamos plotar
select(small, item1, slug, item2, texto) %>%
# adicionando o prefixo do link para a imagem
mutate(small = paste0('https://www.playgwent.com/', small)) %>%
# colocando os exemplos em um reactable
reactable(
compact = TRUE, borderless = TRUE, defaultColDef = colDef(align = 'left'),
style = list(fontFamily = "Roboto", fontSize = "12px"),
columns = list(
small = colDef(name = '', cell = embed_img(height = 80, width = 60), maxWidth = 80),
item1 = colDef(name = 'Carta', maxWidth = 140),
slug = colDef(name = 'Facção', maxWidth = 90),
item2 = colDef(name = 'Similaridade', maxWidth = 90, format = colFormat(digits = 3)),
texto = colDef(name = 'Descrição')
)
)
Dúvidas, sugestões ou críticas? É só me procurar pelo e-mail ou GitHub!